SuperHack/SuperHack CD.bin/CODING/DELPHI/COMM32.ZIP/COMM32.PAS

Pascal/Delphi Source File | 1996-03-19 | 44.7 KB | 1,535 lines

unit Comm32;
//
// This Communications Component is implemented using separate Read and Write
// threads. Messages from the threads are posted to the Comm control which is
// an invisible window. To handle data from the comm port, simply
// attach a handler to 'OnReceiveData'. There is no need to free the memory
// buffer passed to this handler. If TAPI is used to open the comm port, some
// changes to this component are needed ('StartComm' currently opens the comm
// port). The 'OnRequestHangup' event is included to assist this.
//
// David Wann
// Stamina Software
// 28/02/96
// [e-mail]

interface

uses
    Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
    Misc;

const
    // messages from read/write threads
    PWM_GOTCOMMDATA = WM_USER + 1;
    PWM_REQUESTHANGUP = WM_USER + 2;

type
    ECommsError = class( Exception );

    TReadThread = class( TThread )
    protected
        procedure Execute; override;
    public
        hCommFile:             THandle;
        hCloseEvent:        THandle;
        hComm32Window:        THandle;
        function SetupCommEvent( lpOverlappedCommEvent: POverlapped;
                        var lpfdwEvtMask: DWORD ): Boolean;
        function SetupReadEvent( lpOverlappedRead: POverlapped;
                        lpszInputBuffer: LPSTR; dwSizeofBuffer: DWORD;
                        var lpnNumberOfBytesRead: DWORD ): Boolean;
        function HandleCommEvent( lpOverlappedCommEvent: POverlapped;
                        var lpfdwEvtMask: DWORD; fRetrieveEvent: Boolean ): Boolean;
        function HandleReadEvent( lpOverlappedRead: POverlapped;
                        lpszInputBuffer: LPSTR; dwSizeofBuffer: DWORD;
                        var lpnNumberOfBytesRead: DWORD ): Boolean;
        function HandleReadData( lpszInputBuffer: LPCSTR; dwSizeofBuffer: DWORD ): Boolean;
        function ReceiveData( lpNewString: LPSTR; dwSizeofNewString: DWORD ): BOOL;
        procedure PostHangupCall;
    end;

    TWriteThread = class( TThread )
    protected
        procedure Execute; override;
        function HandleWriteData( lpOverlappedWrite: POverlapped;
                pDataToWrite: PChar; dwNumberOfBytesToWrite: DWORD): Boolean;
    public
        hCommFile:             THandle;
        hCloseEvent:        THandle;
        hComm32Window:        THandle;
        function WriteComm( pDataToWrite: LPCSTR; dwSizeofDataToWrite: DWORD ): Boolean;
        procedure PostHangupCall;
    end;

    TReceiveDataEvent = procedure( Buffer: Pointer; BufferLength: Word ) of object;

    TComm32 = class( TComponent )
    private
        { Private declarations }
        ReadThread:                TReadThread;
        WriteThread:            TWriteThread;
        FCommsLogFileName,
        FCommPort:                string;
        hCommFile:                 THandle;
        hCloseEvent:            THandle;
        FOnReceiveData:         TReceiveDataEvent;
        FOnRequestHangup:        TNotifyEvent;
        FHWnd:                    THandle;
        FBaudRate:            DWORD;

        procedure SetCommsLogFileName( LogFileName: string );
        function GetReceiveDataEvent: TReceiveDataEvent;
        procedure SetReceiveDataEvent( AReceiveDataEvent: TReceiveDataEvent );
        function GetRequestHangupEvent: TNotifyEvent;
        procedure SetRequestHangupEvent( ARequestHangupEvent: TNotifyEvent );
        procedure CommWndProc( var msg: TMessage );
    protected
        { Protected declarations }
        procedure CloseReadThread;
        procedure CloseWriteThread;
        procedure ReceiveData( Buffer: PChar; BufferLength: Word );
        procedure RequestHangup;
    public
        { Public declarations }
        constructor Create( AOwner: TComponent ); override;
        destructor Destroy; override;
        function StartComm: Boolean;
        procedure StopComm;
        function WriteCommData( pDataToWrite: PChar; dwSizeofDataToWrite: Word ): Boolean;
    published
        { Published declarations }
        property BaudRate: DWORD read FBaudRate write FBaudRate;
        property CommPort: string read FCommPort write FCommPort;
        property CommsLogFileName: string read FCommsLogFileName write SetCommsLogFileName;
        property OnReceiveData: TReceiveDataEvent
                read GetReceiveDataEvent write SetReceiveDataEvent;
        property OnRequestHangup: TNotifyEvent
                read GetRequestHangupEvent write SetRequestHangupEvent;
    end;

const
// This is the message posted to the WriteThread
// When we have something to write.
    PWM_COMMWRITE = WM_USER+1;

// Default size of the Input Buffer used by this code.
    INPUTBUFFERSIZE = 2048;

var
    CommsLogFile:    Text; // means you can only debug 1 component at a time


procedure LogDebugInfo( outstr: PChar );
procedure LogDebugLastError( dwLastError: DWORD; szPrefix: LPSTR );
procedure Register;

implementation

var
    CommsLogName:    string; // used as a check if file is assigned

(******************************************************************************)
//                                    TCOMM32 PUBLIC METHODS
(******************************************************************************)

constructor TComm32.Create( AOwner: TComponent );
begin
    inherited Create( AOwner );
    FCommPort := 'COM2';
    FCommsLogFileName := '';
    CommsLogName := '';
    ReadThread := nil;
    WriteThread := nil;
    hCommFile := 0;
    if not (csDesigning in ComponentState) then
        FHWnd := AllocateHWnd(CommWndProc);
end;

destructor TComm32.Destroy;
begin
    if not (csDesigning in ComponentState) then
    begin
        DeallocateHWnd(FHwnd);
    end;
    inherited Destroy;
end;

//
//  FUNCTION: StartComm
//
//  PURPOSE: Starts communications over the comm port.
//
//  PARAMETERS:
//    hNewCommFile - This is the COMM File handle to communicate with.
//                   This handle is obtained from TAPI.
//
//  RETURN VALUE:
//    TRUE if able to setup the communications.
//
//  COMMENTS:
//
//    StartComm makes sure there isn't communication in progress already,
//    creates a Comm file, and creates the read and write threads.  It
//    also configures the hNewCommFile for the appropriate COMM settings.
//
//    If StartComm fails for any reason, it's up to the calling application
//    to close the Comm file handle.
//
//
function TComm32.StartComm: Boolean;
var
    commtimeouts:    TCommTimeouts;
    dcb:                Tdcb;
    commprop:        TCommProp;
    fdwEvtMask:        DWORD;
    hNewCommFile: THandle;
begin
    // Are we already doing comm?
    if (hCommFile <> 0) then
        raise ECommsError.Create( 'Already have a comm file open' );

    if CommsLogFileName <> '' then
    begin
        AssignFile( CommsLogFile, fCommsLogFileName );
        Rewrite( CommsLogFile );
    end;

    hNewCommFile := CreateFile(
                            PChar(fCommPort),
                            GENERIC_READ+GENERIC_WRITE,
                            0, {not shared}
                            nil, {no security ??}
                            OPEN_EXISTING,
                            {FILE_ATTRIBUTE_NORMAL+}FILE_FLAG_OVERLAPPED,
                            0 {template} );
    if hNewCommFile = INVALID_HANDLE_VALUE then
        raise ECommsError.Create( 'Error opening com port' );

    // Is this a valid comm handle?
    if GetFileType( hNewCommFile ) <> FILE_TYPE_CHAR then
        raise ECommsError.Create( 'File handle is not a comm handle. ' );

    // Its ok to continue.

    hCommFile := hNewCommFile;

    // Setting and querying the comm port configurations.

    // Configure the comm settings.
    // NOTE: Most Comm settings can be set through TAPI, but this means that
    //       the CommFile will have to be passed to this component.

    GetCommState( hNewCommFile, dcb );
    GetCommProperties( hNewCommFile, commprop );
    GetCommMask( hCommFile, fdwEvtMask );
    GetCommTimeouts( hCommFile, commtimeouts );

    // The CommTimeout numbers will very likely change if you are
    // coding to meet some kind of specification where
    // you need to reply within a certain amount of time after
    // recieving the last byte.  However,  If 1/4th of a second
    // goes by between recieving two characters, its a good
    // indication that the transmitting end has finished, even
    // assuming a 1200 baud modem.

    commtimeouts.ReadIntervalTimeout         := 250;
    commtimeouts.ReadTotalTimeoutMultiplier  := 0;
    commtimeouts.ReadTotalTimeoutConstant    := 0;
    commtimeouts.WriteTotalTimeoutMultiplier := 0;
    commtimeouts.WriteTotalTimeoutConstant   := 0;

    SetCommTimeouts( hCommFile, commtimeouts );

    // fAbortOnError is the only DCB dependancy in TapiComm.
    // Can't guarentee that the SP will set this to what we expect.
    {dcb.fAbortOnError := False; NOT VALID}
    dcb.BaudRate := FBaudRate;
    SetCommState( hNewCommFile, dcb );

    // Create the event that will signal the threads to close.
    hCloseEvent := CreateEvent( nil, True, False, nil );

    if hCloseEvent = 0 then
    begin
         LogDebugLastError( GetLastError, 'Unable to CreateEvent: ' );
         hCommFile := 0;
         Result := False;
         Exit
    end;

    // Create the Read thread.
    try
        ReadThread := TReadThread.Create( True {suspended} );
    except
        LogDebugLastError( GetLastError, 'Unable to create Read thread' );
        raise ECommsError.Create( 'Unable to create Read thread' );
    end;
    ReadThread.hCommFile := hCommFile;
    ReadThread.hCloseEvent := hCloseEvent;
    ReadThread.hComm32Window := FHWnd;
    ReadThread.Resume;

    // Comm threads should have a higher base priority than the UI thread.
    // If they don't, then any temporary priority boost the UI thread gains
    // could cause the COMM threads to loose data.
    ReadThread.Priority := tpHighest;

    // Create the Write thread.
    try
        WriteThread := TWriteThread.Create( True {suspended} );
    except
        LogDebugLastError( GetLastError, 'Unable to create Write thread' );
        raise ECommsError.Create( 'Unable to create Write thread' );
    end;
    WriteThread.hCommFile := hCommFile;
    WriteThread.hCloseEvent := hCloseEvent;
    WriteThread.hComm32Window := FHWnd;
    WriteThread.Resume;

    ReadThread.Priority := tpHigher;

    // Everything was created ok.  Ready to go!
    Result := True;
end; {TComm32.StartComm}

//
//  FUNCTION: StopComm
//
//  PURPOSE: Stop and end all communication threads.
//
//  PARAMETERS:
//    none
//
//  RETURN VALUE:
//    none
//
//  COMMENTS:
//
//    Tries to gracefully signal all communication threads to
//    close, but terminates them if it has to.
//
//
procedure TComm32.StopComm;
begin
    // No need to continue if we're not communicating.
    if hCommFile = 0 then
        Exit;

    LogDebugInfo( 'Stopping the Comm' );

     // Close the threads.
    CloseReadThread;
    CloseWriteThread;

    // Not needed anymore.
    CloseHandle( hCloseEvent );

    // Now close the comm port handle.
    CloseHandle( hCommFile );
    hCommFile := 0;
    if fCommsLogFileName <> '' then
        CloseFile( CommsLogFile );
end; {TComm32.StopComm}

//
//  FUNCTION: WriteCommData(PChar, Word)
//
//  PURPOSE: Send a String to the Write Thread to be written to the Comm.
//
//  PARAMETERS:
//    pszStringToWrite     - String to Write to Comm port.
//    nSizeofStringToWrite - length of pszStringToWrite.
//
//  RETURN VALUE:
//    Returns TRUE if the PostMessage is successful.
//    Returns FALSE if PostMessage fails or Write thread doesn't exist.
//
//  COMMENTS:
//
//    This is a wrapper function so that other modules don't care that
//    Comm writing is done via PostMessage to a Write thread.  Note that
//    using PostMessage speeds up response to the UI (very little delay to
//    'write' a string) and provides a natural buffer if the comm is slow
//    (ie:  the messages just pile up in the message queue).
//
//    Note that it is assumed that pszStringToWrite is allocated with
//    LocalAlloc, and that if WriteCommData succeeds, its the job of the
//    Write thread to LocalFree it.  If WriteCommData fails, then its
//    the job of the calling function to free the string.
//
//
function TComm32.WriteCommData( pDataToWrite: PChar; dwSizeofDataToWrite: Word ): Boolean;
var
    Buffer:    Pointer;
begin
    if WriteThread <> nil then
    begin
        Buffer := Pointer(LocalAlloc( LPTR, dwSizeofDataToWrite+1 ));
        Move( pDataToWrite^, Buffer^, dwSizeofDataToWrite );
        if PostThreadMessage( WriteThread.ThreadID, PWM_COMMWRITE,
                     WPARAM(dwSizeofDataToWrite), LPARAM(Buffer) ) then
        begin
            Result := true;
            Exit;
        end
        else
            LogDebugInfo( 'Failed to Post to Write thread. ' );
    end
    else
        LogDebugInfo( 'Write thread not created' );

    Result := False;
end; {TComm32.WriteCommData}

(******************************************************************************)
//                                    TCOMM32 PROTECTED METHODS
(******************************************************************************)

//
//  FUNCTION: CloseReadThread
//
//  PURPOSE: Close the Read Thread.
//
//  PARAMETERS:
//    none
//
//  RETURN VALUE:
//    none
//
//  COMMENTS:
//
//    Closes the Read thread by signaling the CloseEvent.
//    Purges any outstanding reads on the comm port.
//
//    Note that terminating a thread leaks memory.
//    Besides the normal leak incurred, there is an event object
//    that doesn't get closed.  This isn't worth worrying about
//    since it shouldn't happen anyway.
//
//
procedure TComm32.CloseReadThread;
begin
    // If it exists...
    if ReadThread <> nil then
    begin
        LogDebugInfo( 'Closing Read Thread ');

        // Signal the event to close the worker threads.
        SetEvent( hCloseEvent );

        // Purge all outstanding reads
        PurgeComm( hCommFile, PURGE_RXABORT + PURGE_RXCLEAR );

        // Wait 10 seconds for it to exit.  Shouldn't happen.
        if (WaitForSingleObject(ReadThread.Handle, 10000) = WAIT_TIMEOUT) then
        begin
            LogDebugInfo( 'Read thread not exiting.  Terminating it.' );
            ReadThread.Terminate;
        end;
        ReadThread.Free;
        ReadThread := nil;
    end;
end; {TComm32.CloseReadThread}


//
//  FUNCTION: CloseWriteThread
//
//  PURPOSE: Closes the Write Thread.
//
//  PARAMETERS:
//    none
//
//  RETURN VALUE:
//    none
//
//  COMMENTS:
//
//    Closes the write thread by signaling the CloseEvent.
//    Purges any outstanding writes on the comm port.
//
//    Note that terminating a thread leaks memory.
//    Besides the normal leak incurred, there is an event object
//    that doesn't get closed.  This isn't worth worrying about
//    since it shouldn't happen anyway.
//
//
procedure TComm32.CloseWriteThread;
begin
    // If it exists...
    if WriteThread <> nil then
    begin
        LogDebugInfo( 'Closing Write Thread' );

        // Signal the event to close the worker threads.
        SetEvent(hCloseEvent);

        // Purge all outstanding writes.
        PurgeComm(hCommFile, PURGE_TXABORT + PURGE_TXCLEAR);

        // Wait 10 seconds for it to exit.  Shouldn't happen.
        if WaitForSingleObject( WriteThread.Handle, 10000 ) = WAIT_TIMEOUT then
        begin
            LogDebugInfo( 'Write thread not exiting.  Terminating it.' );
            WriteThread.Terminate;
        end;
        WriteThread.Free;
        WriteThread := nil;
    end;
end; {TComm32.CloseWriteThread}

procedure TComm32.ReceiveData( Buffer: PChar; BufferLength: Word );
begin
    if Assigned(FOnReceiveData) then
        FOnReceiveData( Buffer, BufferLength );
end;

procedure TComm32.RequestHangup;
begin
    if Assigned(FOnRequestHangup) then
        FOnRequestHangup( Self );
end;

(******************************************************************************)
//                                    TCOMM32 PRIVATE METHODS
(******************************************************************************)

procedure TComm32.SetCommsLogFileName( LogFileName: string );
begin
    CommsLogName := LogFileName;
    FCommsLogFileName := LogFileName;
end;

procedure TComm32.CommWndProc( var msg: TMessage );
begin
    case msg.msg of
        PWM_GOTCOMMDATA:
        begin
            ReceiveData( PChar(msg.LParam), msg.WParam );
            LocalFree( msg.LParam );
        end;
        PWM_REQUESTHANGUP:
            RequestHangup;
    end;
end;

function TComm32.GetReceiveDataEvent: TReceiveDataEvent;
begin
    Result := FOnReceiveData;
end;

procedure TComm32.SetReceiveDataEvent( AReceiveDataEvent: TReceiveDataEvent );
begin
    FOnReceiveData := AReceiveDataEvent;
end;

function TComm32.GetRequestHangupEvent: TNotifyEvent;
begin
    Result := FOnRequestHangup;
end;

procedure TComm32.SetRequestHangupEvent( ARequestHangupEvent: TNotifyEvent );
begin
    FOnRequestHangup := ARequestHangupEvent;
end;


(******************************************************************************)
//                                            READ THREAD
(******************************************************************************)

//
//  PROCEDURE: TReadThread.Execute
//
//  PURPOSE: This is the starting point for the Read Thread.
//
//  PARAMETERS:
//    None.
//
//  RETURN VALUE:
//    None.
//
//  COMMENTS:
//
//    The Read Thread uses overlapped ReadFile and sends any data
//    read from the comm port to the Comm32Window.  This is
//    eventually done through a PostMessage so that the Read Thread
//    is never away from the comm port very long.  This also provides
//    natural desynchronization between the Read thread and the UI.
//
//    If the CloseEvent object is signaled, the Read Thread exits.
//
//      Separating the Read and Write threads is natural for a application
//    where there is no need for synchronization between
//    reading and writing.  However, if there is such a need (for example,
//    most file transfer algorithms synchronize the reading and writing),
//    then it would make a lot more sense to have a single thread to handle
//    both reading and writing.
//
//
procedure TReadThread.Execute;
var
     szInputBuffer:    array[0..INPUTBUFFERSIZE-1] of Char;
     nNumberOfBytesRead:    DWORD;

     HandlesToWaitFor:    array[0..2] of THandle;
     dwHandleSignaled:    DWORD;

     fdwEvtMask:            DWORD;

     // Needed for overlapped I/O (ReadFile)
     overlappedRead:        TOverlapped;

     // Needed for overlapped Comm Event handling.
     overlappedCommEvent:    TOverlapped;
label
    EndReadThread;
begin

    FillChar( overlappedRead, Sizeof(overlappedRead), 0 );
    FillChar( overlappedCommEvent, Sizeof(overlappedCommEvent), 0 );

    // Lets put an event in the Read overlapped structure.
    overlappedRead.hEvent := CreateEvent( nil, True, True, nil);
    if overlappedRead.hEvent = 0 then
    begin
         LogDebugLastError( GetLastError, 'Unable to CreateEvent: ' );
         PostHangupCall;
         goto EndReadThread;
    end;

    // And an event for the CommEvent overlapped structure.
    overlappedCommEvent.hEvent := CreateEvent( nil, True, True, nil);
    if overlappedCommEvent.hEvent = 0 then
    begin
         LogDebugLastError( GetLastError, 'Unable to CreateEvent: ' );
         PostHangupCall();
         goto EndReadThread;
    end;

    // We will be waiting on these objects.
    HandlesToWaitFor[0] := hCloseEvent;
    HandlesToWaitFor[1] := overlappedCommEvent.hEvent;
    HandlesToWaitFor[2] := overlappedRead.hEvent;


    // Setup CommEvent handling.

    // Set the comm mask so we receive error signals.
    if not SetCommMask(hCommFile, EV_ERR) then
    begin
        LogDebugLastError( GetLastError, 'Unable to SetCommMask: ' );
        PostHangupCall;
        goto EndReadThread;
    end;

    // Start waiting for CommEvents (Errors)
    if not SetupCommEvent( @overlappedCommEvent,  fdwEvtMask ) then
    begin
        LogDebugLastError( GetLastError, 'Unable to SetupCommEvent1: ' );
        PostHangupCall;
        goto EndReadThread;
    end;

    // Start waiting for Read events.
    if not SetupReadEvent( @overlappedRead,
                    szInputBuffer, INPUTBUFFERSIZE,
                     nNumberOfBytesRead ) then
    begin
        LogDebugLastError( GetLastError, 'Unable to SetupReadEvent: ' );
        PostHangupCall;
        goto EndReadThread;
    end;

    // Keep looping until we break out.
    while True do
    begin
        // Wait until some event occurs (data to read; error; stopping).
        dwHandleSignaled :=
              WaitForMultipleObjects(3, @HandlesToWaitFor,
                    False, INFINITE);

         // Which event occured?
        case dwHandleSignaled of
            WAIT_OBJECT_0:     // Signal to end the thread.
            begin
                // Time to exit.
                OutputDebugString( 'Time to Exit' );
                goto EndReadThread;
            end;

            WAIT_OBJECT_0 + 1: // CommEvent signaled.
            begin
                // Handle the CommEvent.
                if not HandleCommEvent( @overlappedCommEvent,  fdwEvtMask, TRUE ) then
                begin
                    PostHangupCall;
                    LogDebugLastError( GetLastError, 'Unable HandleCommEvent: ' );
                    goto EndReadThread;
                end;

                // Start waiting for the next CommEvent.
                if not SetupCommEvent( @overlappedCommEvent,  fdwEvtMask ) then
                begin
                    PostHangupCall;
                    LogDebugLastError( GetLastError, 'Unable to SetupCommEvent2: ' );
                    goto EndReadThread;
                end;
                {break;??}
            end;

            WAIT_OBJECT_0 + 2: // Read Event signaled.
            begin
                // Get the new data!
                if not HandleReadEvent( @overlappedRead,
                                    szInputBuffer, INPUTBUFFERSIZE,
                                     nNumberOfBytesRead ) then
                begin
                    PostHangupCall;
                    LogDebugLastError( GetLastError, 'Unable to HandleReadEvent: ' );
                    goto EndReadThread;
                end;

                // Wait for more new data.
                if not SetupReadEvent( @overlappedRead,
                                    szInputBuffer, INPUTBUFFERSIZE,
                                     nNumberOfBytesRead ) then
                begin
                    PostHangupCall;
                    goto EndReadThread;
                end;
                {break;}
            end;

            WAIT_FAILED:       // Wait failed.  Shouldn't happen.
            begin
                LogDebugLastError( GetLastError, 'Read WAIT_FAILED: ' );
                PostHangupCall;
                goto EndReadThread;
            end;

            else    // This case should never occur.
            begin
                LogDebugInfo( PChar('Unexpected Wait return value '+
                            IntToStr(dwHandleSignaled)) );
                PostHangupCall;
                goto EndReadThread;
            end;
        end; {case dwHandleSignaled}
    end; {while True}

    // Time to clean up Read Thread.
 EndReadThread:

    LogDebugInfo( 'Read thread shutting down' );
    PurgeComm( hCommFile, PURGE_RXABORT + PURGE_RXCLEAR );
    CloseHandle( overlappedRead.hEvent );
    CloseHandle( overlappedCommEvent.hEvent );
end; {TReadThread.Execute}

//
//  FUNCTION: SetupReadEvent(LPOVERLAPPED, LPSTR, DWORD, LPDWORD)
//
//  PURPOSE: Sets up an overlapped ReadFile
//
//  PARAMETERS:
//    lpOverlappedRead      - address of overlapped structure to use.
//    lpszInputBuffer       - Buffer to place incoming bytes.
//    dwSizeofBuffer        - size of lpszInputBuffer.
//    lpnNumberOfBytesRead  - address of DWORD to place the number of read bytes.
//
//  RETURN VALUE:
//    TRUE if able to successfully setup the ReadFile.  FALSE if there
//    was a failure setting up or if the CloseEvent object was signaled.
//
//  COMMENTS:
//
//    This function is a helper function for the Read Thread.  This
//    function sets up the overlapped ReadFile so that it can later
//    be waited on (or more appropriatly, so the event in the overlapped
//    structure can be waited upon).  If there is data waiting, it is
//    handled and the next ReadFile is initiated.
//    Another possible reason for returning FALSE is if the comm port
//    is closed by the service provider.
//
//
//
function TReadThread.SetupReadEvent( lpOverlappedRead: POverlapped;
     lpszInputBuffer: LPSTR; dwSizeofBuffer: DWORD;
     var lpnNumberOfBytesRead: DWORD ): Boolean;
var
     dwLastError: DWORD;
label
    StartSetupReadEvent;
begin

StartSetupReadEvent:

    Result := False;
    // Make sure the CloseEvent hasn't been signaled yet.
    // Check is needed because this function is potentially recursive.
    if WAIT_TIMEOUT <> WaitForSingleObject(hCloseEvent,0) then
         Exit;

    // Start the overlapped ReadFile.
    if ReadFile( hCommFile,
              lpszInputBuffer^, dwSizeofBuffer,
              lpnNumberOfBytesRead, lpOverlappedRead ) then
    begin
         // This would only happen if there was data waiting to be read.

        LogDebugInfo( 'Data waiting for ReadFile: ');

         // Handle the data.
        if not HandleReadData( lpszInputBuffer, lpnNumberOfBytesRead ) then
            Exit;

         // Start waiting for more data.
        goto StartSetupReadEvent;
    end;

    // ReadFile failed.  Expected because of overlapped I/O.
    dwLastError := GetLastError;


    // LastError was ERROR_IO_PENDING, as expected.
    if dwLastError = ERROR_IO_PENDING then
    begin
         LogDebugInfo( 'Waiting for data from comm connection.' );
         Result := True;
         Exit;
    end;

    // Its possible for this error to occur if the
    // service provider has closed the port.  Time to end.
    if dwLastError = ERROR_INVALID_HANDLE then
    begin
         LogDebugInfo( 'ERROR_INVALID_HANDLE, '+
              'Likely that the Service Provider has closed the port.' );
         Exit;
    end;

    // Unexpected error. No idea what could cause this to happen.
    LogDebugLastError( dwLastError, 'Unexpected ReadFile error: ' );

    PostHangupCall;
end; {TReadThread.SetupReadEvent}

//
//  FUNCTION: HandleReadData(LPCSTR, DWORD)
//
//  PURPOSE: Deals with data after its been read from the comm file.
//
//  PARAMETERS:
//    lpszInputBuffer  - Buffer to place incoming bytes.
//    dwSizeofBuffer   - size of lpszInputBuffer.
//
//  RETURN VALUE:
//    TRUE if able to successfully handle the data.
//    FALSE if unable to allocate memory or handle the data.
//
//  COMMENTS:
//
//    This function is yet another helper function for the Read Thread.
//    It LocalAlloc()s a buffer, copies the new data to this buffer and
//    calls PostWriteToDisplayCtl to let the EditCtls module deal with
//    the data.  Its assumed that PostWriteToDisplayCtl posts the message
//    rather than dealing with it right away so that the Read Thread
//    is free to get right back to waiting for data.  Its also assumed
//    that the EditCtls module is responsible for LocalFree()ing the
//    pointer that is passed on.
//
//
function TReadThread.HandleReadData( lpszInputBuffer: LPCSTR; dwSizeofBuffer: DWORD ): Boolean;
var
    lpszPostedBytes: LPSTR;
    tempstr:                string;
begin
    Result := False;
     // If we got data and didn't just time out empty...
    if dwSizeofBuffer <> 0 then
    begin
        tempstr := lpszInputBuffer;

          // Do something with the bytes read.
        LogDebugInfo( 'Got something from Comm port!!!' );

        lpszPostedBytes := PChar( LocalAlloc( LPTR, dwSizeofBuffer+1 ) );

        if lpszPostedBytes = nil{NULL} then
        begin
            LogDebugLastError( GetLastError, 'LocalAlloc: ' );
            Exit;
        end;

        Move( lpszInputBuffer^, lpszPostedBytes^, dwSizeofBuffer );
        lpszPostedBytes[dwSizeofBuffer] := #0;

        Result := ReceiveData( lpszPostedBytes, dwSizeofBuffer );
    end;
end; {TReadThread.HandleReadData}

//
//  FUNCTION: HandleReadEvent(LPOVERLAPPED, LPSTR, DWORD, LPDWORD)
//
//  PURPOSE: Retrieves and handles data when there is data ready.
//
//  PARAMETERS:
//    lpOverlappedRead      - address of overlapped structure to use.
//    lpszInputBuffer       - Buffer to place incoming bytes.
//    dwSizeofBuffer        - size of lpszInputBuffer.
//    lpnNumberOfBytesRead  - address of DWORD to place the number of read bytes.
//
//  RETURN VALUE:
//    TRUE if able to successfully retrieve and handle the available data.
//    FALSE if unable to retrieve or handle the data.
//
//  COMMENTS:
//
//    This function is another helper function for the Read Thread.  This
//    is the function that is called when there is data available after
//    an overlapped ReadFile has been setup.  It retrieves the data and
//    handles it.
//
//
function TReadThread.HandleReadEvent( lpOverlappedRead: POverlapped;
     lpszInputBuffer: LPSTR; dwSizeofBuffer: DWORD;
     var lpnNumberOfBytesRead: DWORD ): Boolean;
var
    dwLastError: DWORD;
begin
    Result := False;
    if GetOverlappedResult( hCommFile,
            lpOverlappedRead^, lpnNumberOfBytesRead, False ) then
    begin
        Result := HandleReadData( lpszInputBuffer, lpnNumberOfBytesRead );
        Exit;
    end;

    // Error in GetOverlappedResult; handle it.

    dwLastError := GetLastError;

    // Its possible for this error to occur if the
    // service provider has closed the port.  Time to end.
    if dwLastError = ERROR_INVALID_HANDLE then
    begin
        LogDebugInfo( 'ERROR_INVALID_HANDLE, '+
                'Likely that the Service Provider has closed the port.' );
        Exit;
    end;

    LogDebugLastError( dwLastError,
          'Unexpected GetOverlappedResult Read Error: ' );

    PostHangupCall;
end; {TReadThread.HandleReadEvent}

//
//  FUNCTION: SetupCommEvent(LPOVERLAPPED, LPDWORD)
//
//  PURPOSE: Sets up the overlapped WaitCommEvent call.
//
//  PARAMETERS:
//    lpOverlappedCommEvent - Pointer to the overlapped structure to use.
//    lpfdwEvtMask          - Pointer to DWORD to received Event data.
//
//  RETURN VALUE:
//    TRUE if able to successfully setup the WaitCommEvent.
//    FALSE if unable to setup WaitCommEvent, unable to handle
//    an existing outstanding event or if the CloseEvent has been signaled.
//
//  COMMENTS:
//
//    This function is a helper function for the Read Thread that sets up
//    the WaitCommEvent so we can deal with comm events (like Comm errors)
//    if they occur.
//
//
function TReadThread.SetupCommEvent( lpOverlappedCommEvent: POverlapped;
     var lpfdwEvtMask: DWORD ): Boolean;
var
    dwLastError: DWORD;
label
    StartSetupCommEvent;
begin

    Result := False;
StartSetupCommEvent:

     // Make sure the CloseEvent hasn't been signaled yet.
     // Check is needed because this function is potentially recursive.
    if WAIT_TIMEOUT <> WaitForSingleObject( hCloseEvent,0 ) then
        Exit;

    // Start waiting for Comm Errors.
    if WaitCommEvent( hCommFile, lpfdwEvtMask, lpOverlappedCommEvent ) then
    begin
        // This could happen if there was an error waiting on the
        // comm port.  Lets try and handle it.

        LogDebugInfo( 'Event (Error) waiting before WaitCommEvent.' );

        if not HandleCommEvent( nil, lpfdwEvtMask, False ) then
        {??? GetOverlappedResult does not handle "NIL" as defined by Borland}
            Exit;

        // What could cause infinite recursion at this point?
        goto StartSetupCommEvent;
    end;

    // We expect ERROR_IO_PENDING returned from WaitCommEvent
    // because we are waiting with an overlapped structure.

    dwLastError := GetLastError;

    // LastError was ERROR_IO_PENDING, as expected.
    if dwLastError = ERROR_IO_PENDING then
    begin
        LogDebugInfo( 'Waiting for a CommEvent (Error) to occur.' );
        Result := True;
        Exit
    end;

    // Its possible for this error to occur if the
    // service provider has closed the port.  Time to end.
    if dwLastError = ERROR_INVALID_HANDLE then
    begin
        LogDebugInfo( 'ERROR_INVALID_HANDLE, '+
                'Likely that the Service Provider has closed the port.' );
        Exit;
    end;

    // Unexpected error. No idea what could cause this to happen.
    LogDebugLastError( dwLastError, 'Unexpected WaitCommEvent error: ' );
end; {TReadThread.SetupCommEvent}

//
//  FUNCTION: HandleCommEvent(LPOVERLAPPED, LPDWORD, BOOL)
//
//  PURPOSE: Handle an outstanding Comm Event.
//
//  PARAMETERS:
//    lpOverlappedCommEvent - Pointer to the overlapped structure to use.
//    lpfdwEvtMask          - Pointer to DWORD to received Event data.
//     fRetrieveEvent       - Flag to signal if the event needs to be
//                            retrieved, or has already been retrieved.
//
//  RETURN VALUE:
//    TRUE if able to handle a Comm Event.
//    FALSE if unable to setup WaitCommEvent, unable to handle
//    an existing outstanding event or if the CloseEvent has been signaled.
//
//  COMMENTS:
//
//    This function is a helper function for the Read Thread that (if
//    fRetrieveEvent == TRUE) retrieves an outstanding CommEvent and
//    deals with it.  The only event that should occur is an EV_ERR event,
//    signalling that there has been an error on the comm port.
//
//    Normally, comm errors would not be put into the normal data stream
//    as this sample is demonstrating.  Putting it in a status bar would
//    be more appropriate for a real application.
//
//
function TReadThread.HandleCommEvent( lpOverlappedCommEvent: POverlapped;
     var lpfdwEvtMask: DWORD; fRetrieveEvent: Boolean ): Boolean;
var
    dwDummy:            DWORD;
    lpszOutput:        LPSTR;
    szError:            array[0..127] of Char;
    dwErrors,
    nOutput,
    dwLastError:    DWORD;
begin
    Result := False;

    szError[0] := #0;

    lpszOutput := PChar(LocalAlloc( LPTR, 256 ));
    if lpszOutput = nil{NULL} then
    begin
        LogDebugLastError( GetLastError, 'LocalAlloc: ' );
        Exit;
    end;

    // If this fails, it could be because the file was closed (and I/O is
    // finished) or because the overlapped I/O is still in progress.  In
    // either case (or any others) its a bug and return FALSE.
    if fRetrieveEvent then
        if not GetOverlappedResult( hCommFile,
                     lpOverlappedCommEvent^, dwDummy, False ) then
        begin
            dwLastError := GetLastError;

            // Its possible for this error to occur if the
            // service provider has closed the port.  Time to end.
            if dwLastError = ERROR_INVALID_HANDLE then
            begin
                LogDebugInfo( 'ERROR_INVALID_HANDLE, '+
                          'Likely that the Service Provider has closed the port.' );
                Exit;
            end;

            LogDebugLastError( dwLastError,
                     'Unexpected GetOverlappedResult for WaitCommEvent: ' );
            Exit;
        end;

    // Was the event an error?
    if (lpfdwEvtMask and EV_ERR) <> 0 then
    begin
        // Which error was it?
        if not ClearCommError( hCommFile, dwErrors, nil ) then
        begin
            dwLastError := GetLastError;

            // Its possible for this error to occur if the
            // service provider has closed the port.  Time to end.
            if dwLastError = ERROR_INVALID_HANDLE then
            begin
                LogDebugInfo( 'ERROR_INVALID_HANDLE, '+
                      'Likely that the Service Provider has closed the port.' );
                Exit;
            end;

            LogDebugLastError( GetLastError,'ClearCommError: ' );
            Exit;
        end;

        // Its possible that multiple errors occured and were handled
        // in the last ClearCommError.  Because all errors were signaled
        // individually, but cleared all at once, pending comm events
        // can yield EV_ERR while dwErrors equals 0.  Ignore this event.
        if dwErrors = 0 then
            strcat( szError, 'NULL Error' );

        if (dwErrors and CE_FRAME) <> 0 then
        begin
            if szError[0] <> #0 then
                strcat( szError, ' and ' );

            strcat( szError,'CE_FRAME' );
        end;

        if (dwErrors and CE_OVERRUN) <> 0 then
        begin
            if szError[0] <> #0 then
                strcat(szError, ' and ' );

            strcat( szError, 'CE_OVERRUN' );
        end;

        if (dwErrors and CE_RXPARITY) <> 0 then
        begin
            if szError[0] <> #0 then
                strcat( szError, ' and ' );

            strcat( szError, 'CE_RXPARITY' );
        end;

        if (dwErrors and not (CE_FRAME + CE_OVERRUN + CE_RXPARITY)) <> 0 then
        begin
            if szError[0] <> #0 then
                strcat( szError, ' and ' );

            strcat( szError, 'EV_ERR Unknown EvtMask' );
        end;

        nOutput := wsprintf(lpszOutput,
                PChar('Comm Event: '+szError+', EvtMask = '+IntToStr(dwErrors)) );

        ReceiveData( lpszOutput, nOutput );
        Result := True;
        Exit
    end;

    // Should not have gotten here.  Only interested in ERR conditions.

    LogDebugInfo( PChar('Unexpected comm event '+IntToStr(lpfdwEvtMask)) );
end; {TReadThread.HandleCommEvent}

function TReadThread.ReceiveData( lpNewString: LPSTR; dwSizeofNewString: DWORD ): BOOL;
begin
    Result := PostMessage( hComm32Window, PWM_GOTCOMMDATA,
          WPARAM(dwSizeofNewString), LPARAM(lpNewString) );
end;

procedure TReadThread.PostHangupCall;
begin
    PostMessage( hComm32Window, PWM_REQUESTHANGUP, 0, 0 );
end;

(******************************************************************************)
//                                            WRITE THREAD
(******************************************************************************)

//
//  PROCEDURE: TWriteThread.Execute
//
//  PURPOSE: The starting point for the Write thread.
//
//  PARAMETERS:
//    lpvParam - unused.
//
//  RETURN VALUE:
//    DWORD - unused.
//
//  COMMENTS:
//
//    The Write thread uses a PeekMessage loop to wait for a string to write,
//    and when it gets one, it writes it to the Comm port.  If the CloseEvent
//    object is signaled, then it exits.  The use of messages to tell the
//    Write thread what to write provides a natural desynchronization between
//    the UI and the Write thread.
//
//
procedure TWriteThread.Execute;
var
     msg:    TMsg;
     dwHandleSignaled:    DWORD;
     overlappedWrite:        TOverLapped;
label
    EndWriteThread;
begin

     // Needed for overlapped I/O.
     FillChar( overlappedWrite, SizeOf(overlappedWrite), 0 );  {0, 0, 0, 0, NULL}

     overlappedWrite.hEvent := CreateEvent( nil, True, True, nil );
     if overlappedWrite.hEvent = 0 then
     begin
          LogDebugLastError( GetLastError, 'Unable to CreateEvent: ' );
          PostHangupCall;
          goto EndWriteThread;
     end;

     // This is the main loop.  Loop until we break out.
     while True do
     begin
          if not PeekMessage( msg, 0, 0, 0, PM_REMOVE ) then
          begin
                // If there are no messages pending, wait for a message or
                // the CloseEvent.
                dwHandleSignaled :=
                     MsgWaitForMultipleObjects(1, hCloseEvent, False,
                          INFINITE, QS_ALLINPUT);

                case dwHandleSignaled of
                     WAIT_OBJECT_0:     // CloseEvent signaled!
                     begin
                          // Time to exit.
                          goto EndWriteThread;
                     end;

                     WAIT_OBJECT_0 + 1: // New message was received.
                     begin
                          // Get the message that woke us up by looping again.
                          continue;
                     end;

                     WAIT_FAILED:       // Wait failed.  Shouldn't happen.
                     begin
                          LogDebugLastError( GetLastError, 'Write WAIT_FAILED: ' );
                          PostHangupCall;
                          goto EndWriteThread;
                     end;

                     else                // This case should never occur.
                     begin
                          LogDebugInfo( PChar('Unexpected Wait return value '
                                                        +IntToStr(dwHandleSignaled)) );
                          PostHangupCall;
                          goto EndWriteThread;
                     end;
                end;
          end;

          // Make sure the CloseEvent isn't signaled while retrieving messages.
          if WAIT_TIMEOUT <> WaitForSingleObject(hCloseEvent,0) then
                goto EndWriteThread;

          // Process the message.

          // This could happen if a dialog is created on this thread.
          // This doesn't occur in this sample, but might if modified.
          if msg.hwnd <> 0{NULL} then
          begin
                TranslateMessage(msg);
                DispatchMessage(msg);

                continue;
          end;

          // Handle the message.
          case msg.message of
                PWM_COMMWRITE:  // New string to write to Comm port.
                begin
                     LogDebugInfo( 'Writing to comm port' );

                     // Write the string to the comm port.  HandleWriteData
                     // does not return until the whole string has been written,
                     // an error occurs or until the CloseEvent is signaled.
                     if not HandleWriteData( @overlappedWrite,
                                PChar(msg.lParam), DWORD(msg.wParam) ) then
                     begin
                          // If it failed, either we got a signal to end or there
                          // really was a failure.

                          LocalFree( HLOCAL(msg.lParam) );
                          goto EndWriteThread;
                     end;

                     // Data was sent in a LocalAlloc()d buffer.  Must free it.
                     LocalFree( HLOCAL(msg.lParam) );
                end;

                // What other messages could the thread get?
                else
                begin
                     LogDebugInfo( PChar('Unexpected message posted to Write thread: '+
                          IntToStr(msg.message)) );
                     {break;}
                end;
          end; {case}
     end; {main loop}

     // Thats the end.  Now clean up.
  EndWriteThread:

     LogDebugInfo( 'Write thread shutting down' );

     PurgeComm(hCommFile, PURGE_TXABORT + PURGE_TXCLEAR);

     CloseHandle(overlappedWrite.hEvent);
end; {TWriteThread.Execute}


//
//  FUNCTION: HandleWriteData(LPOVERLAPPED, LPCSTR, DWORD)
//
//  PURPOSE: Writes a given string to the comm file handle.
//
//  PARAMETERS:
//    lpOverlappedWrite      - Overlapped structure to use in WriteFile
//    pDataToWrite      - String to write.
//    dwNumberOfBytesToWrite - Length of String to write.
//
//  RETURN VALUE:
//    TRUE if all bytes were written.  False if there was a failure to
//    write the whole string.
//
//  COMMENTS:
//
//    This function is a helper function for the Write Thread.  It
//    is this call that actually writes a string to the comm file.
//    Note that this call blocks and waits for the Write to complete
//    or for the CloseEvent object to signal that the thread should end.
//    Another possible reason for returning FALSE is if the comm port
//    is closed by the service provider.
//
//
function TWriteThread.HandleWriteData( lpOverlappedWrite: POverlapped;
     pDataToWrite: PChar; dwNumberOfBytesToWrite: DWORD): Boolean;
var
    dwLastError,

    dwNumberOfBytesWritten,
    dwWhereToStartWriting,

    dwHandleSignaled:    DWORD;
    HandlesToWaitFor: array[0..1] of THandle;
begin
    dwNumberOfBytesWritten := 0;
    dwWhereToStartWriting := 0; // Start at the beginning.

    HandlesToWaitFor[0] := hCloseEvent;
    HandlesToWaitFor[1] := lpOverlappedWrite^.hEvent;

     // Keep looping until all characters have been written.
     repeat
          // Start the overlapped I/O.
          if not WriteFile(hCommFile,
                     pDataToWrite[ dwWhereToStartWriting ],
                     dwNumberOfBytesToWrite, dwNumberOfBytesWritten,
                     lpOverlappedWrite) then
          begin
                // WriteFile failed.  Expected; lets handle it.
                dwLastError := GetLastError;

                // Its possible for this error to occur if the
                // service provider has closed the port.  Time to end.
                if (dwLastError = ERROR_INVALID_HANDLE) then
                begin
                     LogDebugInfo( 'ERROR_INVALID_HANDLE, '+
                          'Likely that the Service Provider has closed the port.' );
                     Result := False;
                     Exit;
                end;

                // Unexpected error.  No idea what.
                if dwLastError <> ERROR_IO_PENDING then
                begin
                     LogDebugLastError( dwLastError, 'Error to writing to CommFile' );

                     LogDebugInfo( 'Closing TAPI' );
                     PostHangupCall;
                     Result := False;
                     Exit;
                end;

                // This is the expected ERROR_IO_PENDING case.


                // Wait for either overlapped I/O completion,
                // or for the CloseEvent to get signaled.
                dwHandleSignaled :=
                     WaitForMultipleObjects(2, @HandlesToWaitFor,
                          False, INFINITE);

                case dwHandleSignaled of
                     WAIT_OBJECT_0:     // CloseEvent signaled!
                     begin
                          // Time to exit.
                          Result := False;
                          Exit;
                     end;

                     WAIT_OBJECT_0 + 1: // Wait finished.
                     begin
                          // Time to get the results of the WriteFile
                     end;

                     WAIT_FAILED: // Wait failed.  Shouldn't happen.
                     begin
                          LogDebugLastError( GetLastError, 'Write WAIT_FAILED: ' );
                          PostHangupCall;
                          Result := False;
                          Exit
                     end;

                     else // This case should never occur.
                     begin
                          LogDebugInfo( PChar('Unexpected Wait return value '+
                                                    IntToStr(dwHandleSignaled)) );
                          PostHangupCall;
                          Result := False;
                          Exit
                     end;
                end; {case}

                if not GetOverlappedResult(hCommFile,
                            lpOverlappedWrite^,
                            dwNumberOfBytesWritten, TRUE) then
                begin
                     dwLastError := GetLastError();

                     // Its possible for this error to occur if the
                     // service provider has closed the port.
                     if dwLastError = ERROR_INVALID_HANDLE then
                     begin
                          LogDebugInfo('ERROR_INVALID_HANDLE, '+
                                'Likely that the Service Provider has closed the port.');
                          Result := False;
                          Exit;
                     end;

                     // No idea what could cause another error.
                     LogDebugLastError( dwLastError, 'Error writing to CommFile while waiting');
                     LogDebugInfo('Closing TAPI');
                     PostHangupCall;
                     Result := False;
                     Exit;
                end;
          end; {WriteFile failure}

          // Some data was written.  Make sure it all got written.

          Dec( dwNumberOfBytesToWrite, dwNumberOfBytesWritten );
          Inc( dwWhereToStartWriting, dwNumberOfBytesWritten );
     until (dwNumberOfBytesToWrite <= 0);  // Write the whole thing!

     // Wrote the whole string.
     Result := True;
end; {TWriteThread.HandleWriteData}

function TWriteThread.WriteComm( pDataToWrite: LPCSTR; dwSizeofDataToWrite: DWORD ): Boolean;
begin
    Result := PostThreadMessage( ThreadID, PWM_COMMWRITE,
                     WParam(dwSizeofDataToWrite), LParam(pDataToWrite) );
end;

procedure TWriteThread.PostHangupCall;
begin
    PostMessage( hComm32Window, PWM_REQUESTHANGUP, 0, 0 );
end;

(******************************************************************************)
//                                            DEBUG ROUTINES
(******************************************************************************)

//
//  FUNCTION: LogDebugLastError(..)
//
//  PURPOSE: Pretty print a line error to the debugging output.
//
//  PARAMETERS:
//    dwLastError - Actual error code to decipher.
//    pszPrefix   - String to prepend to the printed message.
//
//  RETURN VALUE:
//    none
//
//  COMMENTS:
//
//    Note that there is an internal string length limit of
//    MAXOUTPUTSTRINGLENGTH.  If this length is exceeded,
//    the behavior will be the same as wsprintf, although
//    it will be undetectable.  *KEEP szPrefix SHORT!*
//
//
procedure LogDebugLastError( dwLastError: DWORD; szPrefix: LPSTR );
var
    szLastError: LPSTR;
    szOutputLastError: array[0..MAXOUTPUTSTRINGLENGTH-1] of Char;
begin
    if szPrefix = nil then
        szPrefix := '';

    // Pretty print the error.
    szLastError := FormatLastError(dwLastError, nil, 0);

    // The only reason FormatLastError should fail is "Out of memory".
    if szLastError = nil then
    begin
        wsprintf( szOutputLastError, PChar(szPrefix+'Out of memory') );

        LogDebugInfo( szOutputLastError );

        Exit;
    end;

    wsprintf( szOutputLastError,
              PChar(szPrefix+'GetLastError returned: "'+szLastError+'"') );

    // Pointer returned from FormatLineError *must* be freed!
    LocalFree( HLOCAL(szLastError) );

    // Print it!
    LogDebugInfo( szOutputLastError );
end; {LogDebugLastError}

procedure LogDebugInfo( outstr: PChar );
begin
    if CommsLogName <> '' then
        Writeln( CommsLogFile, outstr );
end; {LogDebugInfo}

procedure Register;
begin
  RegisterComponents('Stamina', [TComm32]);
end;

end.